home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / UTILITY.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  4.0 KB  |  125 lines
  1. ; UTILITY.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Utility procedures                *
  12. ;*    useful in the development of Scheme programs.            *
  13. ;*                                    *
  14. ;*----------------------------------------------------------------------*
  15. ;*                                    *
  16. ;* Created by: TI            Date: 1987            *
  17. ;* Revision history:                            *
  18. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. ;
  24. ; COMPILE-ONLY - Compiles a given file without executing (unless form is a
  25. ;         macro, alias, syntax, or define-integrable) the result.
  26. ;
  27. ;
  28. ; Compiles a given file without executing (unless form is a macro, alias,
  29. ; syntax, or define-integrable) the result. Also report compilation info.
  30. ;
  31. ; Example: (compile-only "file.s" "file.so")   ;generates file.so
  32. ;
  33. (define compile-only
  34.   (lambda (filename1 filename2)
  35.     (if (or (not (string? filename1))
  36.         (not (string? filename2))
  37.         (equal? filename1 filename2))
  38.        (error "COMPILE-ONLY arguments must be distinct file names"
  39.           filename1
  40.           filename2)
  41.     ;else
  42.        (letrec
  43.        ((read-proc (if (string-ci=? (cadddr (filename-split filename1)) ".sw")
  44.               read-sw read))
  45.         (i-port (open-input-file filename1))
  46.         (o-port (open-output-file filename2))
  47.         (loop
  48.           (lambda (form)
  49.         (if (eof-object? form)
  50.            (begin (close-input-port i-port)
  51.               (close-output-port o-port)
  52.               'ok)
  53.            (begin (compile-to-file form)
  54.               (set! form '())               ; for GC
  55.               (loop (read-proc i-port))))))
  56.         (compile-to-file
  57.           (lambda (form)
  58.         (let ((cform (compile form)))
  59.           (when (and (pair? form)
  60.                  (memq (car form)
  61.                    '(MACRO SYNTAX ALIAS DEFINE-INTEGRABLE)))
  62.              (eval cform))
  63.           (prin1 `(%execute (quote ,cform)) o-port)
  64.           (newline o-port)))))
  65.  
  66.       ; body of letrec
  67.  
  68.       (set-line-length! 74 o-port)
  69.       (loop (read-proc i-port))))))
  70.  
  71. ;
  72. ; PP-LOAD - Pretty prints each form of a source file to the console
  73. ;        as it loads that file.
  74. ;
  75. ; Example: (pp-load "file.s")
  76. ;
  77. (define (pp-load filename)
  78.   (define read-proc
  79.     (if (string-ci=? (cadddr (filename-split filename)) ".sw") read-sw read))
  80.   (define (load-form port)
  81.     (let ((form (read-proc port))
  82.       (result '()))
  83.       (if (not (eof-object? form))
  84.       (begin
  85.         (newline)
  86.         (newline)
  87.         (pp form)
  88.         (set! result (eval (compile form)))
  89.         (if (not (eq? result *the-non-printing-object*))
  90.         (begin (newline) (prin1 result)))
  91.         (load-form port)))))
  92.   (if (not (string? filename))
  93.       (error "Argument to PP-LOAD not a filename" filename)
  94.       ;else
  95.       (begin
  96.     (load-form (open-input-file filename))
  97.     (newline)
  98.     'ok)))
  99.  
  100. ;
  101. ; TIMER - measures the execution speed of any arbitrary Scheme expression
  102. ;      The argument EXPR is the expression to be timed while ITER is
  103. ;      the number of times the expression should be invoked. TIMER also
  104. ;      takes into account the time spent in the control loop of the
  105. ;      TIMER function itself by subtracting this from the total time;
  106. ;      therefore, the value returned accurately reflects the time actually
  107. ;      spent executing the expression.
  108. ;
  109. ; Example: (timer (fib 15) 10)     ;report the time taken to execute
  110. ;                 ;(fib 15) 10 times
  111. ;
  112.  
  113. (syntax (timer expr iter)
  114.     (let* ((start-time (clock))
  115.            (end-time (do ((counter 1 (+ counter 1)))
  116.                  ((> counter iter) (clock))
  117.                  ((lambda () #F))))
  118.            (go (begin (gc #T) (clock)))
  119.            (stop (do ((counter 1 (+ counter 1)))
  120.              ((> counter iter) (clock))
  121.              ((lambda () expr))))
  122.            (overhead (- end-time start-time))
  123.            (net-time (- (- stop go) overhead)))
  124.       (/ net-time 18.2)))
  125.